(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)

(* $Id: lexer.mll 10250 2010-04-08 03:58:41Z garrigue $ *)

(* The lexer definition *)

{
  open Lexing
  open Misc
    
  let comment_start_loc = ref [];;
  let in_comment () = !comment_start_loc <> [];;
  
  let print str = print_string str; flush stdout;;
  let prbuf lexbuf = print (Lexing.lexeme lexbuf);;
}

let newline = ('\010' | '\013' | "\013\010")

rule main = parse
  | "`\""
      { print " \""; string lexbuf; main lexbuf }
  | "\""
      { prbuf lexbuf; string lexbuf; main lexbuf }
  | "(*" {
      prbuf lexbuf;
      comment_start_loc := [Location.curr lexbuf];
      comment lexbuf;
      main lexbuf
    }
  | "(*)" {
      prbuf lexbuf;
      comment_start_loc := [Location.curr lexbuf];
      comment lexbuf;
      main lexbuf
    }
  | "'" newline "'"
      { prbuf lexbuf; main lexbuf }
  | "'" [^ '\\' '\'' '\010' '\013'] "'"
      { prbuf lexbuf; main lexbuf }
  | "'\\" ['\\' '\'' '"' 'n' 't' 'b' 'r' ' '] "'"
      { prbuf lexbuf; main lexbuf }
  | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
      { prbuf lexbuf; main lexbuf }
  | "'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'"
      { prbuf lexbuf; main lexbuf }
  | "'\\" _
      { prbuf lexbuf; main lexbuf }
  | "#" [' ' '\t']* (['0'-'9']+) [' ' '\t']*
        ("\"" ([^ '\010' '\013' '"' ] *) "\"")?
        [^ '\010' '\013'] * newline
      { prbuf lexbuf; main lexbuf }
  | eof
      { () }
  | _
      { prbuf lexbuf; main lexbuf }

and comment = parse
  | "(*" {
      prbuf lexbuf;
      comment_start_loc := (Location.curr lexbuf) :: !comment_start_loc;
      comment lexbuf;
    }
  | "*)" {
      prbuf lexbuf;
      match !comment_start_loc with
        | [] -> assert false
        | [_x] -> comment_start_loc := [];
        | _ :: l -> comment_start_loc := l; comment lexbuf;
    }
  | "\""
      { prbuf lexbuf; string lexbuf; comment lexbuf }
  | "''"
      { prbuf lexbuf; comment lexbuf }
  | "'" newline "'"
      { prbuf lexbuf; comment lexbuf }
  | "'" [^ '\\' '\'' '\010' '\013' ] "'"
      { prbuf lexbuf; comment lexbuf }
  | "'\\" ['\\' '"' '\'' 'n' 't' 'b' 'r' ' '] "'"
      { prbuf lexbuf; comment lexbuf }
  | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
      { prbuf lexbuf; comment lexbuf }
  | "'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'"
      { prbuf lexbuf; comment lexbuf }
  | eof
      { () }
  | _
      { prbuf lexbuf; comment lexbuf }

and string = parse
  | '"'
      { prbuf lexbuf }
  | '\\' newline ([' ' '\t'] *)
      { prbuf lexbuf; string lexbuf }
  | '\\' ['\\' '\'' '"' 'n' 't' 'b' 'r' ' ']
      { prbuf lexbuf; string lexbuf }
  | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
      { prbuf lexbuf; string lexbuf }
  | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F']
      { prbuf lexbuf; string lexbuf }
  | '\\' _
      { prbuf lexbuf; string lexbuf }
  | eof
      { () }
  | _
      { prbuf lexbuf; string lexbuf }

{
  let error msg = Printf.eprintf "Error: %s\n%!" msg; exit 1;;
  if Array.length Sys.argv <> 2 then
    error (Printf.sprintf "Usage: %s <src.ml>" Sys.argv.(0));
  let ic = open_in Sys.argv.(1) in
  let lexbuf = Lexing.from_channel ic in
    main lexbuf;
    close_in ic;
}
